home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue25 / icmp / ICMP.ZIP / ICMP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-07-03  |  24.2 KB  |  741 lines
  1. unit icmp;
  2.  
  3. { Copyright 1997 Andreas H÷rstemeier                Version 0.2 1997-07-02   }
  4. { this component is public domain - please check the file readme.txt for     }
  5. { more detailed info on usage and distributing                               }
  6.  
  7. (*@/// interface *)
  8. interface
  9.  
  10. uses
  11.   sysutils,classes,winsock,windows,messages,forms,ip_misc;
  12.  
  13. (*@/// The API stuff for the ICMP.DLL *)
  14. (* Documentation taken from http://www.sockets.com/ms_icmp.htm *)
  15.  
  16. { Microsoft doesn't support the standard way ICMP is implemented using
  17.   sockets, that means by the SOCK_RAW socket type - they only work as
  18.   user administrator! And there's no way to set the TTL for the packets, so
  19.   there's no way to build a TraceRoute using winsock. So this unit uses their
  20.   ICMP.DLL, although MS discourages it's use - once they have a better solution
  21.   this properitary implementation will vanish. So be careful where you
  22.   use this unit!
  23. }
  24.  
  25. const
  26. (*@///   ip status values *)
  27. ip_status_base           = 11000;
  28. ip_success               = 0;
  29. ip_buf_too_small         = ip_status_base +  1;
  30. ip_dest_net_unreachable  = ip_status_base +  2;
  31. ip_dest_host_unreachable = ip_status_base +  3;
  32. ip_dest_prot_unreachable = ip_status_base +  4;
  33. ip_dest_port_unreachable = ip_status_base +  5;
  34. ip_no_resources          = ip_status_base +  6;
  35. ip_bad_options           = ip_status_base +  7;
  36. ip_hw_error              = ip_status_base +  8;
  37. ip_packet_too_big        = ip_status_base +  9;
  38. ip_req_timed_out         = ip_status_base + 10;
  39. ip_bad_req               = ip_status_base + 11;
  40. ip_bad_route             = ip_status_base + 12;
  41. ip_ttl_expired_transmit  = ip_status_base + 13;
  42. ip_ttl_expired_reassem   = ip_status_base + 14;
  43. ip_param_problem         = ip_status_base + 15;
  44. ip_source_quench         = ip_status_base + 16;
  45. ip_option_too_big        = ip_status_base + 17;
  46. ip_bad_destination       = ip_status_base + 18;
  47. ip_addr_deleted          = ip_status_base + 19;
  48. ip_sepc_mtu_change       = ip_status_base + 20;
  49. ip_mtu_change            = ip_status_base + 21;
  50. ip_unload                = ip_status_base + 22;
  51. ip_general_failure       = ip_status_base + 50;
  52. max_ip_status            = ip_general_failure;
  53. ip_pending               = ip_status_base +255;
  54. (*@\\\0000000C01*)
  55.  
  56. type
  57. (*@///   t_ip_options=packed record *)
  58. p_ip_options=^t_ip_options;
  59. t_ip_options=packed record
  60.   Ttl: byte;             (* time to live *)
  61.   Tos: byte;             (* type of service (usually 0) *)
  62.   flags: byte;           (* IP header flags (usually 0) *)
  63.   optionssize: byte;     (* size of options data (usually 0, max 40) *)
  64.   optionsdata: pointer;  (* options data buffer *)
  65. end;
  66. (*@\\\0000000201*)
  67. (*@///   t_icmp_echo_reply=packed record *)
  68. p_icmp_echo_reply=^t_icmp_echo_reply;
  69. t_icmp_echo_reply=packed record
  70.   address: u_long;           (* source address *)
  71.   status: u_long;            (* IP status *)
  72.   rttime: u_long;            (* rount trip time in milliseconds *)
  73.   datasize: word;            (* reply data size *)
  74.   reserved: word;            (* who knows *)
  75.   data: pointer;             (* reply data buffer *)
  76.   ip_options:t_ip_options;   (* reply options *)
  77. end;
  78. (*@\\\*)
  79.  
  80. var
  81.   ICMPCreateFile:function:THandle; stdcall;
  82.   ICMPCloseHandle:function(ICMPHandle:THandle):Boolean; stdcall;
  83.   ICMPSendEcho:function(ICMPHandle: THandle;      (* handle returned from ICMPCreateFile *)
  84.                         DestAddress:longint;      (* destination IP address (network order) *)
  85.                         Requestdata:pointer;      (* pointer to buffer to send *)
  86.                         requestsize:word;         (* length of data in buffer *)
  87.                         RequestOptns: p_ip_options;
  88.                         ReplyBuffer:pointer;      (* see note *)
  89.                         Replysize:dword;          (* length of reply, minimum 1 reply *)
  90.                         Timeout: DWord            (* time in milliseconds to wait for reply *)
  91.                         ):dword; stdcall;
  92.  
  93.  
  94. (* The reply buffer will have an array of ICMP_ECHO_REPLY structures, followed
  95.    by options and the data in ICMP echo reply datagram received. You must
  96.    have root for at least one ICMP echo reply structure, plus 8 bytes for
  97.    an ICMP header *)
  98. (*@\\\0000000D14*)
  99. (*@/// The ICMP constants for winsock like calls *)
  100. type
  101. (*@///   t_ip_header=packed record *)
  102. t_ip_header=packed record
  103.   ip_hl_v: byte;   (* low nibble: header length; high nibble: version *)
  104.   ip_tos: byte;    (* type of service *)
  105.   ip_len: word;    (* total length *)
  106.   ip_id: word;     (* identification *)
  107.   ip_off: word;    (* fragment offset field *)
  108.   ip_ttl: byte;    (* time to live *)
  109.   ip_p: byte;      (* protocol *)
  110.   ip_sum: word;    (* checksum *)
  111.   ip_src,
  112.   ip_dst:longint;  (* source and dest address *)
  113.   end;
  114. (*@\\\*)
  115. (*@///   t_icmp_echo_request=packed record *)
  116. t_icmp_echo_request=packed record
  117.   icmp_type: byte;            (* ICMP type *)
  118.   icmp_code: byte;            (* ICMP code *)
  119.   icmp_cksum: word;           (* ICMP checksum *)
  120.   icmp_id: word;              (* ICMP identification *)
  121.   icmp_seq: word;             (* ICMP sequence number *)
  122.   end;
  123. (*@\\\000000050A*)
  124. (*@///   t_icmp_reply=packed record *)
  125. t_icmp_reply=packed record
  126.   icmp_type: byte;            (* ICMP type *)
  127.   icmp_code: byte;            (* ICMP code *)
  128.   icmp_cksum: word;           (* ICMP checksum *)
  129.   icmp_unused: longint;       (* unused area *)
  130.   icmp_ip: t_ip_header;       (* original IP header which cause the reply *)
  131.   icmp_dgram:array[0..63] of byte;   (* first 64 bits of datagram *)
  132.   end;
  133. (*@\\\000000010D*)
  134. const
  135. (*@///   ICMP types *)
  136.   ICMP_ECHOREPLY           = 0  ;  (* echo reply *)
  137.   ICMP_UNREACH             = 3  ;  (* dest unreachable, codes: *)
  138.     ICMP_UNREACH_NET       = 0  ;  (* bad net *)
  139.     ICMP_UNREACH_HOST      = 1  ;  (* bad host *)
  140.     ICMP_UNREACH_PROTOCOL  = 2  ;  (* bad protocol *)
  141.     ICMP_UNREACH_PORT      = 3  ;  (* bad port *)
  142.     ICMP_UNREACH_NEEDFRAG  = 4  ;  (* IP_DF caused drop *)
  143.     ICMP_UNREACH_SRCFAIL   = 5  ;  (* src route failed *)
  144.   ICMP_SOURCEQUENCH        = 4  ;  (* packet lost, slow down *)
  145.   ICMP_REDIRECT            = 5  ;  (* shorter route, codes: *)
  146.     ICMP_REDIRECT_NET      = 0  ;  (* for network *)
  147.     ICMP_REDIRECT_HOST     = 1  ;  (* for host *)
  148.     ICMP_REDIRECT_TOSNET   = 2  ;  (* for tos and net *)
  149.     ICMP_REDIRECT_TOSHOST  = 3  ;  (* for tos and host *)
  150.   ICMP_ECHO                = 8  ;  (* echo service *)
  151.   ICMP_TIMXCEED            = 11 ;  (* time exceeded, code: *)
  152.     ICMP_TIMXCEED_INTRANS  = 0  ;  (* ttl==0 in transit *)
  153.     ICMP_TIMXCEED_REASS    = 1  ;  (* ttl==0 in reass *)
  154.   ICMP_PARAMPROB           = 12 ;  (* ip header bad *)
  155.   ICMP_TSTAMP              = 13 ;  (* timestamp request *)
  156.   ICMP_TSTAMPREPLY         = 14 ;  (* timestamp reply *)
  157.   ICMP_IREQ                = 15 ;  (* information request *)
  158.   ICMP_IREQREPLY           = 16 ;  (* information reply *)
  159.   ICMP_MASKREQ             = 17 ;  (* address mask request *)
  160.   ICMP_MASKREPLY           = 18 ;  (* address mask reply *)
  161. (*@\\\*)
  162. (*@///   Options for use with [gs]etsockopt at the IP level. (corrected from winsock) *)
  163. (*  IP_OPTIONS          = 1;  *)
  164.  
  165.   IP_TTL              =  4;           { Time to live of IP packet }
  166.   IP_MULTICAST_IF     =  9;           { set/get IP multicast interface   }
  167.   IP_MULTICAST_TTL    = 10;           { set/get IP multicast timetolive  }
  168.   IP_MULTICAST_LOOP   = 11;           { set/get IP multicast loopback    }
  169.   IP_ADD_MEMBERSHIP   = 12;           { add  an IP group membership      }
  170.   IP_DROP_MEMBERSHIP  = 13;           { drop an IP group membership      }
  171.  
  172. (*  IP_DEFAULT_MULTICAST_TTL   = 1;    { normally limit m'casts to 1 hop  }  *)
  173. (*  IP_DEFAULT_MULTICAST_LOOP  = 1;    { normally hear sends if a member  }  *)
  174. (*  IP_MAX_MEMBERSHIPS         = 20;   { per socket; must fit in one mbuf }  *)
  175. (*@\\\0000000301*)
  176.  
  177. function ICMP_checksum(var buf; length:integer):word;
  178. (*@\\\0000000701*)
  179.  
  180. type
  181.   t_icmp_call=(  icmp_dll,         (* only ICMP.DLL calls *)
  182.                  icmp_winsock_ttl, (* Winsock including setting TTL *)
  183.                  icmp_winsock_dll, (* Winsock, but ICMP.DLL for TTL *)
  184.                  icmp_winsock,     (* Winsock, but no TTL *)
  185.                  no_icmp           (* no at all *)
  186.                );
  187. var
  188.   icmp_state:t_icmp_call;
  189.  
  190. type
  191.   TPingEvent = procedure (sender:TObject; status: integer; ip:longint; roundtime:longint) of object;
  192.   TRouteEvent = procedure (sender:TObject; hop: byte; ip:longint; roundtime:longint) of object;
  193.   EICMPError=class(Exception);
  194. (*@///   TICMP=class(TComponent) *)
  195. TICMP=class(TComponent)
  196. protected
  197.   icmp_handle: THandle;  (* for ICMP.DLL mode *)
  198.   f_socket: TSocket;     (* for winsock RAW mode *)
  199. protected
  200.   f_blocksize: byte;
  201.   f_replysize: dword;
  202.   f_timeout: cardinal;
  203.   f_ttl: byte;
  204.   f_address: longint;
  205.   f_hostname: string;
  206.   f_terminated: boolean;
  207.   f_handle: THandle;
  208.   procedure WndProc(var Msg : TMessage); virtual;
  209.   procedure OpenDll;
  210.   procedure OpenSocket;
  211. public
  212.   constructor Create(Aowner:TComponent); override;
  213.   procedure Terminate;
  214.   procedure action; virtual;
  215.   destructor Destroy; override;
  216. end;
  217. (*@\\\0000001401*)
  218. (*@///   TPing=class(TICMP) *)
  219. TPing=class(TICMP)
  220. protected
  221.   f_no_of_packets_rec: integer;
  222.   f_no_of_packets_snd: integer;
  223.   f_roundtime_max: longint;
  224.   f_roundtime_min: longint;
  225.   f_roundtime_med: extended;
  226.   f_on_ping: TPingEvent;
  227.   function GetRoundtimeMin:longint;
  228.   function GetRoundtimeMed:extended;
  229.   procedure UpdateStatistics(roundtime:longint);
  230. public
  231.   property MinimumRoundttime: longint read GetRoundtimeMin;
  232.   property MaximumRoundttime: longint read f_roundtime_max;
  233.   property MeanRoundttime: extended read GetRoundTimeMed;
  234.   property ReceivedPackets: integer read f_no_of_packets_rec;
  235.   property SentPackets: integer read f_no_of_packets_snd;
  236.   constructor Create(Aowner:TComponent); override;
  237.   procedure action; override;
  238.   procedure ReceiveSock;
  239.   procedure SendSock;
  240.   procedure WndProc(var Msg : TMessage); override;
  241.   procedure ResetStatistics;
  242. published
  243.   property Timeout:cardinal read f_timeout write f_timeout;
  244.   property Blocksize: byte read f_blocksize write f_blocksize default 64;
  245.   property TimeToLive: byte read f_ttl write f_ttl default 255;
  246.   property Hostname:string read f_hostname write f_hostname;
  247.   property OnPing: TPingEvent read f_on_ping write f_on_ping;
  248. end;
  249. (*@\\\0000000401*)
  250. (*@///   TTraceRoute=class(TICMP) *)
  251. TTraceRoute=class(TICMP)
  252. protected
  253.   f_on_route: TRouteEvent;
  254.   f_route: TStringlist;
  255.   f_resolve: boolean;
  256. public
  257.   constructor Create(Aowner:TComponent); override;
  258.   procedure action; override;
  259.   destructor Destroy; override;
  260.   property Route: TStringList read f_route;
  261. published
  262.   property ResolveHostname:boolean read f_resolve write f_resolve default false;
  263.   property Timeout:cardinal read f_timeout write f_timeout;
  264.   property Blocksize: byte read f_blocksize write f_blocksize default 64;
  265.   property TimeToLive: byte read f_ttl write f_ttl default 255;
  266.   property Hostname:string read f_hostname write f_hostname;
  267.   property OnRoute: TRouteEvent read f_on_route write f_on_route;
  268. end;
  269. (*@\\\*)
  270.  
  271. const
  272.   uwm_socketevent = wm_user+$102; (* my magic message number *)
  273.  
  274. procedure Register;
  275. (*@\\\0000000701*)
  276. (*@/// implementation *)
  277. implementation
  278.  
  279. const
  280.   f_packet_no: word = 0;
  281.  
  282. var
  283.   hDll: THandle;
  284. (*@/// function ICMP_checksum(var buf; length:integer):word; *)
  285. function ICMP_checksum(var buf; length:integer):word;
  286. var
  287.   p: pointer;
  288.   sum: longint;
  289.   i: integer;
  290. begin
  291.   p:=@buf;
  292.   sum:=0;
  293.   for i:=1 to length div 2 do begin
  294.     sum:=sum+word(p^);
  295.     p:=pointer(longint(p)+2);
  296.     end;
  297.   if length mod 1<>0 then
  298.     sum:=sum+byte(p^);
  299.  
  300.   sum:=(sum shr 16) + (sum and $ffff);
  301.   sum:=sum+(sum shr 16);
  302.   result:=word(NOT sum);
  303.   end;
  304. (*@\\\000000080A*)
  305. (*@/// function now_ms:longint; *)
  306. function now_ms:longint;
  307. var
  308.   systime : TSystemTime;
  309. begin
  310.   GetLocalTime(systime);  (* to leave the date unchanged *)
  311.   result:=systime.wmilliseconds+1000*systime.wsecond+60000*systime.wminute;
  312.   end;
  313. (*@\\\0000000110*)
  314.  
  315. (*@/// class ticmp(TComponent) *)
  316. (*@/// constructor TICMP.Create(Aowner:TComponent); *)
  317. constructor TICMP.Create(Aowner:TComponent);
  318. begin
  319.   inherited create(AOwner);
  320.   f_timeout:=5000;  (* 5 second *)
  321.   f_blocksize:=64;
  322.   f_ttl:=255;
  323.   f_socket:=INVALID_SOCKET;
  324.   icmp_handle:=invalid_handle_value;
  325.   f_handle:=AllocateHwnd(self.WndProc);
  326.   end;
  327. (*@\\\0000000901*)
  328. (*@/// destructor TICMP.Destroy; *)
  329. destructor TICMP.Destroy;
  330. begin
  331.   if icmp_handle<>invalid_handle_value then
  332.     ICMPCloseHandle(icmp_handle);
  333.   if f_socket<>INVALID_SOCKET then
  334.     Winsock.CloseSocket(f_socket);
  335.   inherited destroy;
  336.   end;
  337. (*@\\\0000000508*)
  338. (*@/// procedure TICMP.action; *)
  339. procedure TICMP.action;
  340. begin
  341.   f_terminated:=false;
  342.   f_replysize:=16+sizeof(t_icmp_echo_reply)+f_blocksize;
  343.   f_address:=lookup_hostname(f_hostname);
  344.   end;
  345. (*@\\\0000000401*)
  346. (*@/// procedure TICMP.Terminate; *)
  347. procedure TICMP.Terminate;
  348. begin
  349.   f_terminated:=true;
  350.   end;
  351. (*@\\\*)
  352. (*@/// procedure TICMP.OpenDll; *)
  353. procedure TICMP.OpenDll;
  354. begin
  355.   if icmp_handle=invalid_handle_value then
  356.     icmp_handle:=ICMPCreateFile;
  357.   end;
  358. (*@\\\0000000501*)
  359. (*@/// procedure TICMP.OpenSocket; *)
  360. procedure TICMP.OpenSocket;
  361. begin
  362.   if f_socket=INVALID_SOCKET then begin
  363.     f_socket:=Winsock.Socket(PF_INET,SOCK_RAW,IPPROTO_ICMP);
  364.     winsock.WSAAsyncSelect(f_socket,f_handle,uwm_socketevent,fd_read);
  365.     end;
  366.   end;
  367. (*@\\\0000000401*)
  368.  
  369. (*@/// procedure TICMP.WndProc(var Msg : TMessage); *)
  370. procedure TICMP.WndProc(var Msg : TMessage);
  371. begin
  372. {   if msg.msg<>uwm_socketevent then EXIT; }
  373. {   if msg.lparamhi=socket_error then }
  374. {   else begin }
  375. {     case msg.lparamlo of }
  376. {         fd_read: }
  377. {       end; }
  378. {     end; }
  379.   end;
  380. (*@\\\0000000A01*)
  381. (*@\\\000000031C*)
  382. (*@/// class tping(TICMP) *)
  383. (*@/// constructor TPing.Create(Aowner:TComponent); *)
  384. constructor TPing.Create(Aowner:TComponent);
  385. begin
  386.   inherited create(AOwner);
  387.   f_blocksize:=64;
  388.   end;
  389. (*@\\\0000000401*)
  390. (*@/// procedure TPing.action; *)
  391. procedure TPing.action;
  392. var
  393.   requestdata,replybuffer: pointer;
  394.   p_reply: p_icmp_echo_reply;
  395.   requestoptions: t_ip_options;
  396. begin
  397.   inherited action;
  398.   case icmp_state of
  399. (*@///     icmp_dll:       send and receive the ping packets via ICMP.DLL *)
  400. icmp_dll: begin
  401.   OpenDll;
  402.   requestdata:=NIL;
  403.   replybuffer:=NIL;
  404.   f_replysize:=16+sizeof(t_icmp_echo_reply)+f_blocksize;
  405.   try
  406.     GetMem(requestdata,f_blocksize);
  407.     fillchar(requestdata^,f_blocksize,#$a7);
  408.     GetMem(replybuffer,f_replysize);
  409.  
  410.     requestoptions.ttl:=f_ttl;    (* a ping should live near infinity *)
  411.     requestoptions.tos:=0;
  412.     requestoptions.flags:=0;
  413.     requestoptions.optionssize:=0;
  414.     requestoptions.optionsdata:=NIL;
  415.  
  416.     if f_terminated then EXIT;
  417.     inc(f_no_of_packets_snd);
  418.     if ICMPSendEcho(icmp_handle,f_address,
  419.                     requestdata,f_blocksize,
  420.                     @requestoptions,
  421.                     replybuffer,f_replysize,
  422.                     f_timeout) = 1 then begin
  423.       p_reply:=p_icmp_echo_reply(replybuffer);
  424.       if assigned(f_on_ping) then
  425.         f_on_ping(self,p_reply^.status,p_reply^.address,p_reply^.rttime);
  426.       if (p_reply^.status=ip_success) and
  427.          (p_reply^.address=f_address) then begin
  428.         inc(f_no_of_packets_rec);
  429.         UpdateStatistics(p_reply^.rttime);
  430.         end;
  431.       end
  432.     else
  433.       if assigned(f_on_ping) then
  434.         f_on_ping(self,ip_req_timed_out,f_address,0);
  435.   finally
  436.     if requestdata<>NIL then
  437.       FreeMem(requestdata,f_blocksize);
  438.     if replybuffer<>NIL then
  439.       FreeMem(replybuffer,f_replysize);
  440.     end;
  441.   end;
  442. (*@\\\0000002301*)
  443. (*@///     icmp_winsock*:  send the ping packets via winsock, receive is asynchron *)
  444. icmp_winsock_ttl, icmp_winsock_dll, icmp_winsock: begin
  445.   OpenSocket;
  446.   if f_terminated then EXIT;
  447.   inc(f_no_of_packets_snd);
  448.   SendSock;
  449.   end;
  450. (*@\\\0000000601*)
  451.     no_icmp: raise EICMPError.Create('No ICMP available');
  452.     end;
  453.   end;
  454. (*@\\\0000000901*)
  455. (*@/// procedure TPing.ReceiveSock;             // receive a ICMP packet *)
  456. procedure TPing.ReceiveSock;
  457. type
  458. (*@///   treply_buf=record *)
  459. treply_buf=record
  460.   ip_header  : t_ip_header;
  461.   icmp_header: t_icmp_echo_request;
  462.   time       : longint;
  463.   end;
  464. (*@\\\*)
  465. var
  466.   replybuffer: pointer;
  467.   from: TSockAddrIn;
  468.   whereto_len: integer;
  469. begin
  470.   replybuffer:=NIL;
  471.   f_replysize:=sizeof(t_icmp_echo_request)+
  472.                sizeof(t_ip_header)+
  473.                sizeof(longint)+
  474.                f_blocksize;
  475.   try
  476.     GetMem(replybuffer,f_replysize);
  477.     from.sin_family:=AF_INET;
  478.     from.sin_port:=0;
  479.     from.sin_addr.S_addr:=f_address;
  480.     recvfrom(f_socket,replybuffer^,f_replysize,0,from,whereto_len);
  481.     if t_ip_header(replybuffer^).ip_hl_v=$45 then begin
  482.         if (treply_buf(replybuffer^).icmp_header.icmp_id=word(self)) and
  483.            assigned(f_on_ping) then
  484.           f_on_ping(self,0,treply_buf(replybuffer^).ip_header.ip_src,
  485.             now_ms-treply_buf(replybuffer^).time);
  486.       end;
  487.   finally
  488.     if replybuffer<>NIL then
  489.       FreeMem(replybuffer,f_replysize);
  490.     end;
  491.   end;
  492. (*@\\\0002001549001549*)
  493. (*@/// procedure TPing.SendSock;                // send a ICMP packet *)
  494. procedure TPing.SendSock;
  495. type
  496. (*@///   ticmp_sendblock=record *)
  497. ticmp_sendblock=record
  498.   icmp_header: t_icmp_echo_request;
  499.   time       : longint;
  500.   data       : char;               (* to be extended dynamically *)
  501.   end;
  502. (*@\\\*)
  503. (*@///   treply_buf=record *)
  504. treply_buf=record
  505.   ip_header  : t_ip_header;
  506.   icmp_header: t_icmp_echo_request;
  507.   time       : longint;
  508.   end;
  509. (*@\\\*)
  510. var
  511.   requestdata: pointer;
  512.   whereto: TSockAddr;
  513.   whereto_len: integer;
  514.   rq_size: integer;
  515. begin
  516.   requestdata:=NIL;
  517.   rq_size:=sizeof(t_icmp_echo_request)+f_blocksize+sizeof(longint);
  518.   try
  519.     GetMem(requestdata,rq_size);
  520.     ticmp_sendblock(requestdata^).icmp_header.icmp_type := ICMP_ECHO;
  521.     ticmp_sendblock(requestdata^).icmp_header.icmp_code := 0;
  522.     ticmp_sendblock(requestdata^).icmp_header.icmp_cksum := 0;
  523.     ticmp_sendblock(requestdata^).icmp_header.icmp_seq := f_packet_no;
  524.     inc(f_packet_no);
  525.     ticmp_sendblock(requestdata^).icmp_header.icmp_id := word(self);
  526.     fillchar(ticmp_sendblock(requestdata^).data,f_blocksize,#$a7);
  527.     ticmp_sendblock(requestdata^).time:=now_ms;
  528.     ticmp_sendblock(requestdata^).icmp_header.icmp_cksum := ICMP_checksum(requestdata^,rq_size);
  529.     whereto_len:=sizeof(whereto);
  530.     whereto.sin_family:=AF_INET;
  531.     whereto.sin_port:=0;
  532.     whereto.sin_addr.S_addr:=f_address;
  533.     if sendto(f_socket,requestdata^,rq_size,
  534.       0,whereto,whereto_len)=SOCKET_ERROR then
  535.         WSAGetLastError;
  536.   finally
  537.     if requestdata<>NIL then
  538.       FreeMem(requestdata,sizeof(t_icmp_echo_request)+f_blocksize);
  539.     end;
  540.   end;
  541. (*@\\\0030001401001501001501*)
  542. (*@/// function TPing.GetRoundtimeMin:longint; *)
  543. function TPing.GetRoundtimeMin:longint;
  544. begin
  545.   if f_roundtime_min=maxint then
  546.     result:=-1
  547.   else
  548.     result:=f_roundtime_min;
  549.   end;
  550. (*@\\\0000000315*)
  551. (*@/// function TPing.GetRoundtimeMed:extended; *)
  552. function TPing.GetRoundtimeMed:extended;
  553. begin
  554.   if f_no_of_packets_rec>0 then
  555.     result:=f_roundtime_med/f_no_of_packets_rec
  556.   else
  557.     result:=0;
  558.   end;
  559. (*@\\\000000060F*)
  560. (*@/// procedure TPing.ResetStatistics; *)
  561. procedure TPing.ResetStatistics;
  562. begin
  563.   f_no_of_packets_rec:=0;
  564.   f_no_of_packets_snd:=0;
  565.   f_roundtime_max:=-1;
  566.   f_roundtime_min:=maxint;
  567.   f_roundtime_med:=0;
  568.   end;
  569. (*@\\\0000000716*)
  570. (*@/// procedure TPing.UpdateStatistics(roundtime:longint); *)
  571. procedure TPing.UpdateStatistics(roundtime:longint);
  572. begin
  573.   if f_roundtime_min>roundtime then
  574.     f_roundtime_min:=roundtime;
  575.   if f_roundtime_max<roundtime then
  576.     f_roundtime_max:=roundtime;
  577.   f_roundtime_med:=f_roundtime_med+roundtime;
  578.   end;
  579. (*@\\\0000000701*)
  580.  
  581. (*@/// procedure TPing.WndProc(var Msg : TMessage); *)
  582. procedure TPing.WndProc(var Msg : TMessage);
  583. begin
  584.   if msg.msg<>uwm_socketevent then EXIT;
  585.   if msg.lparamhi=socket_error then
  586.   else begin
  587.     case msg.lparamlo of
  588.         fd_read: ReceiveSock;
  589.       end;
  590.     end;
  591.   end;
  592. (*@\\\*)
  593. (*@\\\0000000301*)
  594. (*@/// class TTraceRoute(TICMP) *)
  595. (*@/// constructor TTraceRoute.Create(Aowner:TComponent); *)
  596. constructor TTraceRoute.Create(Aowner:TComponent);
  597. begin
  598.   inherited create(AOwner);
  599.   f_blocksize:=64;
  600.   f_route:=TStringlist.Create;
  601.   f_resolve:=false;
  602.   end;
  603. (*@\\\0000000601*)
  604. (*@/// procedure TTraceRoute.action; *)
  605. procedure TTraceRoute.action;
  606. var
  607.   requestdata,replybuffer: pointer;
  608.   p_reply: p_icmp_echo_reply;
  609.   requestoptions: t_ip_options;
  610.   i: integer;
  611. begin
  612.   inherited action;
  613.   f_route.Clear;
  614.   case icmp_state of
  615.     icmp_dll,
  616.     icmp_winsock_dll:  OpenDll;
  617.     icmp_winsock_ttl:  raise EICMPError.Create('Not yet implemented');
  618.     icmp_winsock,
  619.     no_icmp:           raise EICMPError.Create('No ICMP.DLL found');
  620.     end;
  621.  
  622.   requestdata:=NIL;
  623.   replybuffer:=NIL;
  624.   try
  625.     GetMem(requestdata,f_blocksize);
  626.     fillchar(requestdata^,f_blocksize,#$a7);
  627.     f_replysize:=16+sizeof(t_icmp_echo_reply)+f_blocksize;
  628.     GetMem(replybuffer,f_replysize);
  629.  
  630.     i:=0;
  631.     while (i<f_ttl) do begin
  632.       if f_terminated then BREAK;
  633.       requestoptions.ttl:=i+1;
  634.       requestoptions.tos:=0;
  635.       requestoptions.flags:=0;
  636.       requestoptions.optionssize:=0;
  637.       requestoptions.optionsdata:=NIL;
  638.  
  639.       if ICMPSendEcho(icmp_handle,f_address,
  640.                       requestdata,f_blocksize,
  641.                       @requestoptions,
  642.                       replybuffer,f_replysize,
  643.                       f_timeout) = 1 then begin
  644.         p_reply:=p_icmp_echo_reply(replybuffer);
  645.         if (p_reply^.status=ip_success) and
  646.            (p_reply^.address=f_address) then begin
  647.            f_terminated:=true;
  648.            inc(i);
  649.           end
  650.         else if (p_reply^.status=ip_ttl_expired_transmit) then
  651.           inc(i)
  652.         else
  653.           {};
  654.         if ((p_reply^.status=ip_success) or
  655.            (p_reply^.status=ip_ttl_expired_transmit)) then begin
  656.           if f_resolve then
  657.             f_route.add(resolve_hostname(p_reply^.address))
  658.           else
  659.             f_route.add(ip2string(p_reply^.address));
  660.           if assigned(f_on_route) then
  661.             f_on_route(self,i,p_reply^.address,p_reply^.rttime);
  662.           end;
  663.         end;
  664.       end;
  665.   finally
  666.     if requestdata<>NIL then
  667.       FreeMem(requestdata,f_blocksize);
  668.     if replybuffer<>NIL then
  669.       FreeMem(replybuffer,f_replysize);
  670.     end;
  671.   end;
  672. (*@\\\000C003701003701003901*)
  673. (*@/// destructor TTraceRoute.Destroy; *)
  674. destructor TTraceRoute.Destroy;
  675. begin
  676.   f_route.Free;
  677.   inherited destroy;
  678.   end;
  679. (*@\\\0000000310*)
  680. (*@\\\0000000201*)
  681.  
  682. (*@/// procedure shutdown; FAR; *)
  683. procedure shutdown; FAR;
  684. begin
  685.   if hDll<>0 then  FreeLibrary(hDll);
  686.   end;
  687. (*@\\\0000000301*)
  688.  
  689. (*@/// procedure Register; *)
  690. procedure Register;
  691. begin
  692.   RegisterComponents('Internet', [TPing]);
  693.   RegisterComponents('Internet', [TTraceRoute]);
  694.   end;
  695. (*@\\\000000042E*)
  696. (*@\\\0000000C01*)
  697. (*@/// initialization *)
  698. var
  699.   f_socket: TSocket;
  700.   h: integer;
  701. (*@/// function check_dll:boolean; *)
  702. function check_dll:boolean;
  703. begin
  704.   SetErrorMode(sem_NoOpenFileErrorBox);   (* keep it silent *)
  705.   hDll:=LoadLibrary('ICMP.DLL');
  706.   if hdll<>0 then begin
  707.     @ICMPCreateFile:=GetProcAddress(hdll,'IcmpCreateFile');
  708.     @ICMPCloseHandle:=GetProcAddress(hdll,'IcmpCloseHandle');
  709.     @ICMPSendEcho:=GetProcAddress(hdll,'IcmpSendEcho');
  710.     result:=true;
  711.     end
  712.   else
  713.     result:=false;        (* no ICMP possible *)
  714.   end;
  715. (*@\\\0000000D07*)
  716. begin
  717.   f_socket:=Winsock.Socket(PF_INET,SOCK_RAW,IPPROTO_ICMP);  (* check for raw socket *)
  718.   if f_socket=INVALID_SOCKET then begin
  719.     if check_dll then
  720.       icmp_state:=icmp_dll
  721.     else
  722.       icmp_state:=no_icmp;
  723.     end
  724.   else begin
  725.     h:=64;   (* just an arbitrary number *)
  726.     if Winsock.SetSockOpt(f_socket,IPPROTO_IP, IP_TTL, pchar(@h), sizeof(h))<>0 then begin
  727.       winsock.WSAGetLastError;
  728.       if check_dll then
  729.         icmp_state:=icmp_winsock_dll
  730.       else
  731.         icmp_state:=icmp_winsock;
  732.       end
  733.     else
  734.       icmp_state:=icmp_winsock_ttl;
  735.     closesocket(f_socket);
  736.     end;
  737.   AddExitProc(Shutdown);
  738.   end.
  739. (*@\\\0000000F1A*)
  740. (*@\\\0001000011000801*)
  741.